#lang racket


(require "../ast/main.rkt"
         "../base/main.rkt")

(provide
 ; points
 point
 
 ; lines
 arc
 elliptical-arc
 ellipse
 line
 line-closed
 nurbs-curve
 spline
 spline-closed
 spline-tan
 spline-closed-tan
 
 ; surfaces
 annulus
 ngon
 nurbs-surface
 star
 surface
 
 ; solids 
 box
 cone
 cone-frustum
 cylinder
 pyramid
 sphere
 
 ; generic shapes
 circle
 circle-surface
 
 rectangle
 rectangle-surface
 
 ; text
 text
 
 ; transformations 
 extrude
 intersect
 join
 
 loft
 loft-closed
 loft-surface
 loft-solid
 ruled-loft
 ruled-loft-closed
 ruled-loft-surface
 ruled-loft-solid
 
 move
 offset
 
 rotate
 rotate-x
 rotate-y
 rotate-z
 
 scale-center
 scale
 
 section
 section-line
 section-surface
 
 slice
 subtract
 sweep
 thicken
 union 
 
 ; lang
 cen
 x-cen
 x-pos
 x-neg
 y-cen
 y-pos
 y-neg
 z-cen
 z-pos
 z-neg
 
 align-key
 align-key-list
 align-simple
 
 function-curve
 lift
 
 on
 on-left
 on-right
 on-front
 on-back
 on-top
 on-bottom
 
 sequence
 
 ; cad
 layer
 
 ortho
 perspective
 wireframe
 realistic
 auto-view
 manual-view
 view
 view-ortho-top
 view-perspective)


; macros

(define-syntax define-sequence-constructor
  (syntax-rules ()
    ((_ (name arg ...) (impl-name impl-arg ...))
     (define name
       (case-lambda
         ((arg ... node/nodes)
          (impl-name impl-arg ... arg ... (node-or-sequence node/nodes)))
         ((arg ... node . nodes)
          (impl-name impl-arg ... arg ... (sequence (cons node nodes)))))))))

(define-syntax define-sequence-constructor*
  (syntax-rules ()
    ((_ (name arg ...) (impl-name impl-arg ...))
     (define name
       (case-lambda
         ((arg ... node/nodes)
          (impl-name impl-arg ... (node-or-sequence node/nodes)))
         ((arg ... node . nodes)
          (impl-name impl-arg ... (sequence (cons node nodes)))))))))


; utils

(define (node-or-sequence node/nodes)
  (if (list? node/nodes)
      (sequence (map node-or-sequence node/nodes))
      node/nodes))

(define (rotate-normal normal-p shape)
  (rotate uz normal-p shape))

(define (move-and-rotate-normal base-p normal-p shape)
  (move base-p
        (rotate-normal normal-p shape)))

(define (move-and-rotate-axis base-p top-p shape)
  (move base-p
        (if (eq-c base-p top-p)
            shape
            (rotate uz (sub-c top-p base-p) shape))))


; predicates

(define (angle? a)
  (number? a))

(define (distance? d)
  (and (number? d) (positive? d)))

(define (nonnegative-number? r)
  (and (number? r) (not (negative? r))))

(define (nonnegative-integer? r)
  (and (integer? r) (not (negative? r))))

(define (coord-list? lst)
  (and (list? lst) (every is-coord lst)))

(define (node? expr)
  (is-a? expr node%))


; points

(define (point-impl c)
  (assert-types 'point-impl (list is-coord) (list c))
  (new point-node% (c c)))

(define point
  (case-lambda
    ((c)
     (point-impl c))
    ((x y z)
     (point (xyz x y z)))))


; lines

; arc

(define (arc-impl angle radius)
  (assert-types 'arc-impl (list number? nonnegative-number?) (list angle radius))
  (cond ((= radius 0) (point u0))
        ((= angle 0) (point (x radius)))
        (else
         (let ((angle (coterminal angle)))
           (if (= angle 0)
               (circle radius)
               (new arc-node% (angle angle) (radius radius)))))))

(define arc
  (case-lambda
    ((r angle)
     (arc-impl angle r))
    ((c r angle)
     (move
      c
      (arc r angle)))
    ((c r begin-angle end-angle)
     (move
      c
      (rotate-z
       begin-angle
       (arc r (- end-angle begin-angle)))))))

; /arc


; elliptical-arc

(define (elliptical-arc-impl angle x-radius y-radius)
  (assert-types 'elliptical-arc-impl (list number? nonnegative-number? nonnegative-number?) (list angle x-radius y-radius))
  (cond ((= x-radius y-radius) (arc x-radius angle))
        ((= x-radius 0) (line u0 (y y-radius))) ; edit: depends on the angle
        ((= y-radius 0) (line u0 (x x-radius))) ; edit: depends on the angle
        ((= angle 0) (point (x x-radius)))
        (else
         (let ((angle (coterminal angle)))
           (if (= angle 0)
               (ellipse x-radius y-radius)
               (new elliptical-arc-node% (angle angle) (x-radius x-radius) (y-radius y-radius)))))))

(define elliptical-arc
  (case-lambda
    ((x-r y-r angle)
     (elliptical-arc-impl angle x-r y-r))
    ((c x-r y-r angle)
     (move
      c
      (elliptical-arc x-r y-r angle)))
    ((c x-r y-r begin-angle end-angle)
     (move
      c
      (rotate-z
       begin-angle
       (elliptical-arc x-r y-r (- end-angle begin-angle)))))))

; /elliptical-arc


; ellipse

(define (ellipse-impl x-radius y-radius)
  (assert-types 'ellipse-impl (list nonnegative-number? nonnegative-number?) (list x-radius y-radius))
  (cond ((= x-radius y-radius) (circle x-radius))
        ((= x-radius 0) (line u0 (y y-radius)))
        ((= y-radius 0) (line u0 (x x-radius)))
        (else
         (new ellipse-node% (x-radius x-radius) (y-radius y-radius)))))

(define ellipse
  (case-lambda
    ((x-r y-r)
     (ellipse-impl x-r y-r))
    ((c x-r y-r)
     (move c (ellipse x-r y-r)))))

; /ellipse


; line & line-closed

(define (line-impl closed? cs)
  (assert-types 'line-impl (list boolean? coord-list?) (list closed? cs))
  (new line-node% (closed? closed?) (cs cs)))

; edit: eq-c: what is the threshold?
(define line
  (case-lambda
    ((cs)
     (if (eq-c (first cs) (last cs))
         (line-impl #t (butlast cs))
         (line-impl #f cs)))
    ((c1 c2 . cs)
     (line (list* c1 c2 cs)))))

; edit: eq-c: what is the threshold?
(define line-closed
  (case-lambda
    ((cs)
     (cond ((eq-c (first cs) (last cs))
            (displayln "Warning: line-closed: parameter (cs): first and last coords must not be identical because 'line-closed' automatically closes the line; last coord will be dropped")
            (line-impl #t (butlast cs)))
           (else
            (line-impl #t cs))))
    ((c1 c2 . cs)
     (line-closed (list* c1 c2 cs)))))

; /line & line-closed


(define (nurbs-curve controls knots)
  (new nurbs-curve-node% (controls controls) (knots knots)))


; spline, spline-closed, spline-tan & spline-closed-tan

(define (spline-impl closed? cs type)
  (assert-types 'spline-impl (list boolean? coord-list? spline-type?) (list closed? cs type))
  (new spline-node% (closed? closed?) (cs cs) (type type)))

; edit: eq-c: what is the threshold?
(define spline
  (case-lambda
    ((cs)
     (if (eq-c (first cs) (last cs))
         (spline-impl #t (butlast cs) (auto-spline-type))
         (spline-impl #f cs (auto-spline-type))))
    ((c1 c2 . cs)
     (spline (list* c1 c2 cs)))))

; edit: eq-c: what is the threshold?
(define spline-closed
  (case-lambda
    ((cs)
     (cond ((eq-c (first cs) (last cs))
            (displayln "Warning: spline-closed: parameter (cs): first and last coords must not be identical because 'spline-closed' automatically closes the line; last coord will be dropped")
            (spline-impl #t (butlast cs) (auto-spline-type)))
           (else
            (spline-impl #t cs (auto-spline-type)))))
    ((c1 c2 . cs)
     (spline-closed (list* c1 c2 cs)))))

; edit: eq-c: what is the threshold?
(define (spline-tan cs begin-tangent end-tangent)
  (if (eq-c (first cs) (last cs))
      (spline-impl #t (butlast cs) (tangent-spline-type begin-tangent end-tangent))
      (spline-impl #f cs (tangent-spline-type begin-tangent end-tangent))))

; edit: eq-c: what is the threshold?
(define (spline-closed-tan cs begin-tangent end-tangent)
  (cond ((eq-c (first cs) (last cs))
         (displayln "Warning: spline-closed-tan: parameter (cs): first and last coords must not be identical because 'spline-closed-tan' automatically closes the line; last coord will be dropped")
         (spline-impl #t (butlast cs) (tangent-spline-type begin-tangent end-tangent)))
        (else
         (spline-impl #t cs (tangent-spline-type begin-tangent end-tangent)))))

; /spline, spline-closed, spline-tan & spline-closed-tan


;(define (square-impl side)
;  (assert-types 'square-impl (list nonnegative-number?) (list side))
;  (if (= side 0)
;      (point u0)
;      (rectangle side side)))


; surfaces

; annulus

(define (annulus-impl begin-radius end-radius)
  (assert-types 'annulus-impl (list nonnegative-number? nonnegative-number?) (list begin-radius end-radius))
  (cond ((= begin-radius end-radius) (circle begin-radius))
        ((= begin-radius 0) (circle-surface end-radius))
        ; ((= end-radius 0) ; edit: what does this mean?
        (else
         (new annulus-node% (begin-radius begin-radius) (end-radius end-radius)))))

(define annulus
  (case-lambda
    ((begin-radius end-radius)
     (annulus-impl begin-radius end-radius))
    ((c begin-radius end-radius)
     (move c (annulus begin-radius end-radius)))))

; /annulus


; mesh

(define (mesh cs-lst)
  (error 'mesh "Not implemented"))


; ngon

(define (ngon-impl sides radius)
  (assert-types 'ngon-impl (list nonnegative-integer? nonnegative-number?) (list sides radius))
  (cond ((= radius 0) (point u0))
        ((= sides 0) (point u0))
        ;((= sides 1) (line (x width))) ; edit: a line... but how?
        ;((= sides 2) ; edit what is this?
        ;((= sides +inf.0) (circle radius)) ; edit: necessary?
        (else
         (new ngon-node% (radius radius) (sides sides)))))

(define ngon
  (case-lambda
    ((sides c)
     (rotate (pol-phi c) (ngon-impl sides (pol-rho c))))
    ((sides c1 c2)
     (move c1 (rotate (pol-phi c2) (ngon-impl sides (pol-rho c2)))))))

; /ngon


(define (nurbs-surface controls u-knots v-knots)
  (new nurbs-surface-node% (controls controls) (u-knots u-knots) (v-knots v-knots)))


; star

(define (star-impl sides stride radius)
  (assert-types
   'star-impl
   (list nonnegative-integer? nonnegative-integer? nonnegative-number?)
   (list sides stride radius))
  (cond ((= radius 0) (point u0))
        ((= sides 0) (point u0))
        ; edit: other cases (see ngon)
        (else
         (new star-node% (radius radius) (sides sides) (stride stride)))))

(define star
  (case-lambda
    ((sides stride c)
     (rotate (pol-phi c) (star-impl sides stride (pol-rho c))))
    ((sides stride c1 c2)
     (move c1 (rotate (pol-phi c2) (star-impl sides stride (pol-rho c2)))))))


; surface

(define (surface-impl node)
  (new surface-node% (node node)))

(define surface
  (case-lambda
    ((closed-curve)
     (surface-impl closed-curve))
    ((s1 s2)
     (if (and (node? s1) (node? s2))
         (surface-impl (sequence s1 s2))
         (surface-impl (list s1 s2))))
    ((s1 s2 s3)
     (if (and (node? s1) (node? s2) (node? s3))
         (surface-impl (sequence s1 s2 s3))
         (surface-impl (list s1 s2 s3))))
    ((s1 s2 s3 s4)
     (if (and (node? s1) (node? s2) (node? s3) (node? s4))
         (surface-impl (sequence s1 s2 s3 s4))
         (surface-impl (list s1 s2 s3 s4))))
    ((cs)
     (apply surface cs))))

; /surface


; solids


; box

(define (box-impl width length height)
  (assert-types
   'box-impl
   (list nonnegative-number? nonnegative-number? nonnegative-number?)
   (list width length height))
  (cond ((= width length height 0) (point u0))
        ((= width length 0) (line u0 (z height)))
        ((= width height 0) (line u0 (y length)))
        ((= length height 0) (line u0 (x width)))
        ; ((= width 0) (rectangle (line u0 (y length)) (line u0 (z height))) ; edit: not possible (yet?)
        ; ((= length 0) (rectangle (line u0 (x width)) (line u0 (z height))) ; edit: not possible (yet?)
        ; ((= height 0) (rectangle (line u0 (x width)) (line u0 (y length))) ; edit: not possible (yet?)
        (else
         (new box-node% (width width) (length length) (height height)))))

(define box
  (case-lambda
    ((c1 c2)
     (let ((c (sub-c c1 c2)))
       (move
        (midcoord c1 c2)
        (box (abs (xyz-x c)) (abs (xyz-y c)) (abs (xyz-z c))))))
    ((w l h)
     (box-impl w l h))
    ((c w l h)
     (move c (box w l h)))))

; edit: box-centered?

; /box


; cone

(define (cone-impl r h)
  (new cone-node% (radius r) (height h)))

(define (cone-crh c r h)
  (move c (cone r h)))

(define (cone-crc c1 r c2)
  (move-and-rotate-axis c1 c2 (cone r (distance c1 c2))))

(define cone
  (case-lambda
    ((r h)
     (cone-impl r h))
    ((c r h/c)
     (if (number? h/c)
         (cone-crh c r h/c)
         (cone-crc c r h/c)))))

; /cone


; cone-frustum

(define (cone-frustum-impl r h top-r)
  (assert-types
   'cone-frustum-impl
   (list nonnegative-number? nonnegative-number? nonnegative-number?)
   (list r h top-r))
  (cond ((= r top-r) (cylinder r h))
        ((= h 0) (circle (max r top-r)))
        (else  
         (new cone-frustum-node% (base-radius r) (top-radius top-r) (height h)))))

(define (cone-frustum-crhr c r h top-r)
  (move c (cone-frustum r h top-r)))

(define (cone-frustum-crcr c1 r c2 top-r)
  (move-and-rotate-axis
   c1
   c2
   (cone-frustum r (distance c1 c2) top-r)))

(define cone-frustum
  (case-lambda
    ((r h top-r)
     (cone-frustum-impl r h top-r))
    ((c r h/c top-r)
     (if (number? h/c)
         (cone-frustum-crhr c r h/c top-r)
         (cone-frustum-crcr c r h/c top-r)))))

; /cone-frustum


; cylinder

(define (cylinder-impl radius height)
  (cond ((and (= radius 0) (= height 0))
         (point u0))
        ((= radius 0)
         (line u0 (z height)))
        ((= height 0)
         (circle-surface radius))
        (else
         (new cylinder-node% (radius radius) (height height)))))

(define (cylinder-crh c r h)
  (move c (cylinder r h)))

(define (cylinder-crc c1 r c2)
  (move-and-rotate-axis
   c1
   c2
   (cylinder r (distance c1 c2))))

(define cylinder
  (case-lambda
    ((r h)
     (cylinder-impl r h))
    ((c r h/c)
     (if (number? h/c)
         (cylinder-crh c r h/c)
         (cylinder-crc c r h/c)))))

; /cylinder


;(define (elliptical-cone x-radius y-radius height))
;(define (gengon width sides fillet-width height))
;(define (mesh vertices faces))
;(define (paraboloid radius height))

;(define (platonic-solids width sides))


; pyramid

(define (pyramid-impl sides width height)
  (new pyramid-node% (width width) (sides sides) (height height)))

(define (pyramid-scwh sides c w h)
  (move c (pyramid sides w h)))

(define (pyramid-scwc sides c1 w c2)
  (move-and-rotate-axis
   c1
   c2
   (pyramid sides w (distance c1 c2))))

(define pyramid
  (case-lambda
    ((sides w h)
     (pyramid-impl sides w h))
    ((sides c w h/c)
     (if (number? h/c)
         (pyramid-scwh sides c w h/c)
         (pyramid-scwc sides c w h/c)))))

; /pyramid


; sphere

(define (sphere-impl radius)
  (new sphere-node% (radius radius)))

(define sphere
  (case-lambda
    ((r)
     (sphere-impl r))
    ((c r)
     (move c (sphere r)))))

; /sphere


;(define (spindle radius height))
;(define (superellipsoid width length height))
;(define (torus base-radius section-radius))
;(define (truncated-icosahedron width))
;(define (wedge width height))


; generic shapes

; circle & circle-surface

(define (circle-impl c type radius)
  (assert-types 'circle-impl (list is-coord primitive-type? nonnegative-number?) (list c type radius))
  (if (= radius 0)
      (point u0)
      (new circle-node% (c c) (type type) (radius radius))))

(define circle
  (case-lambda
    ((r)
     (circle-impl u0 (line-primitive-type) r))
    ((c r)
     (circle-impl c (line-primitive-type) r))))

(define circle-surface
  (case-lambda
    ((r)
     (circle-impl u0 (surface-primitive-type) r))
    ((c r)
     (circle-impl c (surface-primitive-type) r))))

; /circle & circle-surface


; rectangle & rectangle-surface

(define (rectangle-impl type width length)
  (assert-types 'rectangle-impl (list primitive-type? nonnegative-number? nonnegative-number?) (list type width length))
  (cond ;((= width length) (square-impl width)) ; edit: infinite loop between rectangle and square
    ((= width 0) (line u0 (y length)))
    ((= length 0) (line u0 (x width)))
    (else
     (new rectangle-node% (type type) (width width) (length length)))))

(define (rectangle-wl type w l)
  (rectangle-impl type w l))

(define (rectangle-line-cc c1 c2)
  (let ((c (sub-c c1 c2)))
    (move
     (midcoord c1 c2)
     (rectangle (abs (xyz-x c)) (abs (xyz-y c))))))

(define (rectangle-surface-cc c1 c2)
  (let ((c (sub-c c1 c2)))
    (move
     (midcoord c1 c2)
     (rectangle-surface (abs (xyz-x c)) (abs (xyz-y c))))))

(define rectangle
  (case-lambda
    ((w/c l/c)
     (if (and (number? w/c) (number? l/c))
         (rectangle-wl (line-primitive-type) w/c l/c)
         (rectangle-line-cc w/c l/c)))
    ((c w l)
     (move c (rectangle-surface w l)))))

(define rectangle-surface
  (case-lambda
    ((w/c l/c)
     (if (and (number? w/c) (number? l/c))
         (rectangle-wl (surface-primitive-type) w/c l/c)
         (rectangle-surface-cc w/c l/c)))
    ((c w l)
     (move c (rectangle-surface w l)))))

; /rectangle


; text

(define (text-impl t r s str)
  (assert-types 'text-impl (list is-coord matrix? is-coord string?) (list t r s str))
  (new text-node% (t t) (r r) (s s) (str str)))

(define text
  (case-lambda
    ((t dir s str)
     (let ((cross (if (= (collinearity-c dir ux) 0) (cross-c dir ux) (collinear-cross-c ux))))
       (text-impl
        t
        (m-rotation (angle-c dir ux) cross)
        s
        str)))))

; /text


; transformations

; edit: add shape to 'assert-types'
(define (extrude length dir node)
  (assert-types 'extrude (list number? is-coord node?) (list length dir node))
  (new extrude-node% (length length) (dir dir) (node node)))


;(define (guide-loft guide shapes))


; intersect

(define (intersect-impl node)
  (new intersect-node% (node node)))

(define-sequence-constructor (intersect) (intersect-impl))

; /intersect


;(define (lattice shape))


; join

(define (join-impl node)
  (new join-node% (node node)))

(define-sequence-constructor (join) (join-impl))

; /join


; loft

; edit: put 'shapes' in assert-types
(define (loft-impl loft-type closed? node)
  (assert-types 'loft-impl (list loft-type? boolean? node?) (list loft-type closed? node))
  (new loft-node% (loft-type loft-type) (loft-fit-type (smooth-loft-fit-type)) (closed? closed?) (node node)))

(define-sequence-constructor (loft) (loft-impl (auto-loft-type) #f))
(define-sequence-constructor (loft-closed) (loft-impl (auto-loft-type) #t))
(define-sequence-constructor (loft-surface) (loft-impl (surface-loft-type) #f))
(define-sequence-constructor (loft-surface-closed) (loft-impl (surface-loft-type) #t))
(define-sequence-constructor (loft-solid) (loft-impl (solid-loft-type) #f))
(define-sequence-constructor (loft-solid-closed) (loft-impl (solid-loft-type) #t))


(define (ruled-loft-impl loft-type closed? node)
  (assert-types 'loft-impl (list loft-type? boolean? node?) (list loft-type closed? node))
  (new loft-node% (loft-type loft-type) (loft-fit-type (ruled-loft-fit-type)) (closed? closed?) (node node)))

(define-sequence-constructor (ruled-loft) (ruled-loft-impl (auto-loft-type) #f))
(define-sequence-constructor (ruled-loft-closed) (ruled-loft-impl (auto-loft-type) #t))
(define-sequence-constructor (ruled-loft-surface) (ruled-loft-impl (surface-loft-type) #f))
(define-sequence-constructor (ruled-loft-surface-closed) (ruled-loft-impl (surface-loft-type) #t))
(define-sequence-constructor (ruled-loft-solid) (ruled-loft-impl (solid-loft-type) #f))
(define-sequence-constructor (ruled-loft-solid-closed) (ruled-loft-impl (solid-loft-type) #t))

; /loft


;(define (mirror plane shape))


; move

;(define (move c node)
;  (assert-types 'move (list is-coord node?) (list c node))
;  (if (eq-c c u0)
;      node
;      (new move-node% (c c) (node node))))

(define (move-impl c node)
  (assert-types 'move (list is-coord node?) (list c node))
  (if (eq-c c u0)
      node
      (new move-node% (c c) (node node))))

(define-sequence-constructor* (move c) (move-impl c))

; /move


(define (offset distance node)
  (assert-types 'offset (list number? node?) (list distance node))
  (new offset-node% (distance distance) (node node)))


;(define (path-loft path shapes))
;(define (revolve axis shape))


; rotate

(define (rotate-impl angle normal node)
  (assert-types 'rotate-impl (list number? is-coord node?) (list angle normal node))
  (new rotate-node% (angle angle) (normal normal) (node node)))

(define (rotate-an a n node)
  (rotate-impl a n node))

(define (rotate-cc c1 c2 node)
  (let ((n (if (< (collinearity-c c1 c2) 0)
               (collinear-cross-c c1)
               (cross-c c1 c2))))
    (rotate (angle-c c1 c2) n node)))

(define rotate
  (case-lambda
    ((a/c c node/nodes)
     (if (number? a/c)
         (rotate-an a/c c (node-or-sequence node/nodes))
         (rotate-cc a/c c (node-or-sequence node/nodes))))
    ((a/c c node . nodes)
     (rotate a/c c (cons node nodes)))))

(define rotate-x
  (case-lambda
    ((n node/nodes)
     (rotate n ux node/nodes))
    ((n node . nodes)
     (rotate-x n (cons node nodes)))))

(define rotate-y
  (case-lambda
    ((n node/nodes)
     (rotate n uy node/nodes))
    ((n node . nodes)
     (rotate-y n (cons node nodes)))))

(define rotate-z
  (case-lambda
    ((n node/nodes)
     (rotate n uz node/nodes))
    ((n node . nodes)
     (rotate-z n (cons node nodes)))))

; /rotate


; scale

(define (scale-impl type c node)
  (assert-types 'scale-impl (list scaling-type? is-coord node?) (list type c node))
  (new scale-node% (type type) (c c) (node node)))

(define-sequence-constructor (scale-center c) (scale-impl (center-scaling-type)))

(define-sequence-constructor* (scale n/c)
  (scale-impl
   (origin-scaling-type)
   (if (number? n/c) (xyz n/c n/c n/c) n/c)))

; /scale


; section

(define (section-impl type plane node)
  (assert-types 'section-impl (list section-type? matrix? node?) (list type plane node))
  (new section-node% (type type) (plane plane) (node node)))

; edit: replace 'line-section-type' with 'auto-section-type'
(define-sequence-constructor (section plane) (section-impl (line-section-type)))

(define-sequence-constructor (section-line plane) (section-impl (line-section-type)))
(define-sequence-constructor (section-surface plane) (section-impl (surface-section-type)))

; /section


(define (slice node1 node2)
  (assert-types 'slice (list node? node?) (list node1 node2))
  (new slice-node% (node1 node1) (node2 node2)))


; subtract

; edit: add 'shape1' and 'shape2' to 'assert-types'
(define (subtract-impl node)
  (new subtract-node% (node node)))

(define-sequence-constructor (subtract) (subtract-impl))

; /subtract


(define (sweep path node)
  (assert-types 'sweep (list node? node?) (list path node))
  (new sweep-node% (path path) (node node)))

(define (thicken distance node)
  (assert-types 'thicken (list number? node?) (list distance node))
  (new thicken-node% (distance distance) (node node)))


; union

(define (union-impl node)
  (assert-types 'union (list node?) (list node))
  (new union-node% (node node)))

(define-sequence-constructor (union) (union-impl))

; /union


; lang


; align

(define (make-list-fn val1)
  (λ (val2)
    (thunk (list val1 val2))))

(define cen (make-list-fn 'cen))
(define x-cen (make-list-fn 'x))
(define x-pos (make-list-fn '+x))
(define x-neg (make-list-fn '-x))
(define y-cen (make-list-fn 'y))
(define y-pos (make-list-fn '+y))
(define y-neg (make-list-fn '-y))
(define z-cen (make-list-fn 'z))
(define z-pos (make-list-fn '+z))
(define z-neg (make-list-fn '-z))

(define (make-key-align-type sym)
  (match sym
    ('cen (center-key-align-type))
    ('+x (x-pos-key-align-type))
    ('-x (x-neg-key-align-type))
    ('+y (y-pos-key-align-type))
    ('-y (y-neg-key-align-type))
    ('+z (z-pos-key-align-type))
    ('-z (z-neg-key-align-type))))

(define (make-shape-align-type sym)
  (match sym
    ('x (x-cen-shape-align-type))
    ('+x (x-pos-shape-align-type))
    ('-x (x-neg-shape-align-type))
    ('y (y-cen-shape-align-type))
    ('+y (y-pos-shape-align-type))
    ('-y (y-neg-shape-align-type))
    ('z (z-cen-shape-align-type))
    ('+z (z-pos-shape-align-type))
    ('-z (z-neg-shape-align-type))))

(define (align-key-impl key-fn shape-fns)
  (assert-types 'align-key-impl (list procedure? (listof procedure?)) (list key-fn shape-fns))
  (let ((key-align-type (make-key-align-type (first (key-fn)))))
    (let ((key-align-types (map (const key-align-type) shape-fns))
          (key-shape (second (key-fn)))
          (shape-align-types (map (λ. make-shape-align-type first call) shape-fns))
          (node (sequence (map (λ. second call) shape-fns))))
      (new align-node%
           (key-align-types key-align-types)
           (key-shape key-shape)
           (shape-align-types shape-align-types)
           (node node)))))

(define align-key
  (case-lambda
    ((fns)
     (align-key-impl (first fns) (rest fns)))
    ((fn1 fn2 . fns)
     (align-key (list* fn1 fn2 fns)))))

(define (align-key-list key-fn . shape-fns)
  (align-key-impl key-fn shape-fns))

(define align-simple
  (case-lambda
    ((key-fn shape-fn shapes)
     (align-key-impl (key-fn (first shapes)) (map shape-fn (rest shapes))))
    ((key-fn shape-fn shape1 shape2 . shapes)
     (align-simple key-fn shape-fn (list* shape1 shape2 shapes)))))

; /align


; function-curve

(define (function-curve-impl functional-par)
  (new parametric-node% (functional-par functional-par)))

(define function-curve
  (case-lambda
    ((fn) (function-curve fn 0 1))
    ((fn t0 t1) (function-curve-impl (functional-curve fn t0 t1)))))

; /function-curve


(define (lift proc node)
  (assert-types 'lift (list procedure? node?) (list proc node))
  (new lift-node% (proc proc) (node node)))


; on

(define (make-on-type sym)
  (match sym
    ('+x (x-pos-on-type))
    ('right (x-pos-on-type))
    ('-x (x-neg-on-type))
    ('left (x-neg-on-type))
    ('+y (y-pos-on-type))
    ('back (y-pos-on-type))
    ('-y (y-neg-on-type))
    ('front (y-pos-on-type))
    ('+z (z-pos-on-type))
    ('top (z-pos-on-type))
    ('-z (z-neg-on-type))
    ('bottom (z-neg-on-type))))

(define (on-impl type node)
  (assert-types 'on-impl (list on-type? node?) (list type node))
  (new on-node% (type type) (node node)))

(define-sequence-constructor* (on type) (on-impl (make-on-type type)))

(define on-right (cλ on 'right))
(define on-left (cλ on 'left))
(define on-back (cλ on 'back))
(define on-front (cλ on 'front))
(define on-top (cλ on 'top))
(define on-bottom (cλ on 'bottom))

; /on


; sequence

(define (sequence-impl nodes)
  ;(assert-types 'sequence-impl (list (listof node?)) (list nodes))
  (let ((node (new sequence-node% (nodes nodes))))
    (set-field! srcloc
                node
                (map-append (lambda (node)
                              (get-field srcloc node))
                            nodes))
    node))

(define sequence
  (case-lambda
    ((nodes)
     (sequence-impl nodes))
    ((node . nodes)
     (sequence (cons node nodes)))))

; /sequence


; cad

; layer

(define (layer-impl name node)
  (assert-types 'layer-impl (list string? node?) (list name node))
  (new layer-node% (name name) (node node)))

(define-sequence-constructor* (layer name)
  (layer-impl name))

; /layer


; view

(define realistic (realistic-view-style))
(define wireframe (wireframe-view-style))

(define ortho (ortho-projection-type))

(define perspective
  (case-lambda
    (() (perspective 50))
    ((lens) (perspective-projection-type lens))))

(define (view-impl type projection-type style node)
  (assert-types
   'view-impl
   (list view-type? projection-type? view-style? node?)
   (list type projection-type style node))
  (new view-node% (type type) (projection-type projection-type) (style style) (node node)))

(define (auto-view direction projection-type style node/nodes)
  (view-impl (auto-view-type direction) projection-type style (node-or-sequence node/nodes)))

(define (manual-view center target projection-type style node/nodes)
  (view-impl (manual-view-type center target) projection-type style (node-or-sequence node/nodes)))

(define view
  (case-lambda
    ((direction projection-type node/nodes)
     (auto-view projection-type wireframe (node-or-sequence node/nodes)))
    ((center target projection-type node/nodes)
     (manual-view center target projection-type wireframe (node-or-sequence node/nodes)))))

(define view-ortho-top
  (case-lambda
    ((node/nodes)
     (auto-view (z -1) ortho wireframe (node-or-sequence node/nodes)))
    ((center/style node/nodes)
     (if (is-coord center/style)
         (manual-view center/style u0 ortho (node-or-sequence node/nodes))
         (auto-view (z -1) ortho 50 center/style (node-or-sequence node/nodes))))
    ((center style node/nodes)
     (manual-view center u0 ortho style (node-or-sequence node/nodes)))))

(define view-perspective
  (case-lambda
    ((node/nodes) (auto-view (xyz 1 1 -1) (perspective) realistic (node-or-sequence node/nodes)))))

; /view